home *** CD-ROM | disk | FTP | other *** search
/ Delphi 2.0 - Programmer's Utilities Power Pack / Delphi 2.0 Programmer's Utilities Power Pack.iso / e_to_l / imlib201 / tdbmulti.pas < prev    next >
Pascal/Delphi Source File  |  1996-09-15  |  65KB  |  2,099 lines
  1. {Copyright 1995 by
  2.  Kevin Adams, 74742,1444
  3.  Jan Dekkers, 72130,353
  4.  
  5. }
  6.  
  7. {Part of Imagelib VCL/DLL Library.
  8.  
  9. Written by Jan Dekkers and Kevin Adams}
  10.  
  11.  
  12. unit TDBMulti;
  13.  
  14. interface
  15.  
  16. uses
  17.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Forms, Controls,
  18.   extctrls, StdCtrls, DLL20LIN, menus, DB, DBTables, Mask, Buttons, MPlayer;
  19.  
  20.  
  21.  
  22. { TDBMultiImage }
  23. Type
  24.   TDBMultiImage = class(TCustomControl)
  25.   private
  26.     FDataLink           :  TFieldDataLink;
  27.     FPicture            :  TPicture;
  28.     FBorderStyle        :  TBorderStyle;
  29.     FAutoDisplay        :  Boolean;
  30.     FStretch            :  Boolean;
  31.     FCenter             :  Boolean;
  32.     FPictureLoaded      :  Boolean;
  33.     FUpdateAsJpeg       :  Boolean;
  34.     FReserved           :  Byte;
  35.     Fdither             :  byte;
  36.     FResolution         :  byte;
  37.     FSaveQuality        :  byte;
  38.     FSaveSmooth         :  byte;
  39.     procedure DataChange(Sender: TObject);
  40.     function GetDataField: string;
  41.     function GetDataSource: TDataSource;
  42.     function GetField: TField;
  43.     function GetReadOnly: Boolean;
  44.     procedure PictureChanged(Sender: TObject);
  45.     procedure SetAutoDisplay(Value: Boolean);
  46.     procedure SetBorderStyle(Value: TBorderStyle);
  47.     procedure SetCenter(Value: Boolean);
  48.     procedure SetDataField(const Value: string);
  49.     procedure SetDataSource(Value: TDataSource);
  50.     procedure SetPicture(Value: TPicture);
  51.     procedure SetReadOnly(Value: Boolean);
  52.     procedure SetStretch(Value: Boolean);
  53.     procedure UpdateData(Sender: TObject);
  54.     procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
  55.     procedure CMExit(var Message: TCMExit); message CM_EXIT;
  56.     procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
  57.     procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
  58.     procedure WMCut(var Message: TMessage); message WM_CUT;
  59.     procedure WMCopy(var Message: TMessage); message WM_COPY;
  60.     procedure WMPaste(var Message: TMessage); message WM_PASTE;
  61.     procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
  62.   protected
  63.     procedure CreateParams(var Params: TCreateParams); override;
  64.     function GetPalette: HPALETTE; override;
  65.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  66.     procedure KeyPress(var Key: Char); override;
  67.     procedure Notification(AComponent: TComponent;
  68.       Operation: TOperation); override;
  69.     procedure Paint; override;
  70.     function GetSmooth : Byte;
  71.     procedure SetSmooth(smooth : Byte);
  72.     function GetQuality : Byte;
  73.     procedure SetQuality(Quality : Byte);
  74.     function GetDither : Byte;
  75.     procedure SetDither(dith : Byte);
  76.     function GetRes : Byte;
  77.     procedure SetRes(res : Byte);
  78.   public
  79.     BFiletype           :  String;
  80.     Bwidth              :  Integer;
  81.     BHeight             :  Integer;
  82.     Bbitspixel          :  Integer;
  83.     Bplanes             :  Integer;
  84.     Bnumcolors          :  Integer;
  85.     BSize               :  Longint;
  86.     Bcompression        :  String;
  87.     constructor Create(AOwner: TComponent); override;
  88.     destructor Destroy; override;
  89.     procedure CopyToClipboard;
  90.     procedure CutToClipboard;
  91.     procedure LoadPicture;
  92.     procedure PasteFromClipboard;
  93.     procedure LoadFromFile(filename : TFilename);
  94.     procedure SaveToFile(filename : TFilename);
  95.     procedure SaveToFileAsBMP(filename : TFilename);
  96.     procedure SaveToFileAsJpeg(filename : TFilename);
  97.     function GetInfoAndType : String;
  98.     property Field: TField read GetField;
  99.     property Picture: TPicture read FPicture write SetPicture;
  100.   published
  101.     property JPegDither : Byte read GetDither write SetDither;
  102.     property JPegResolution : Byte read GetRes write SetRes;
  103.     property JPegSaveQuality : Byte read GetQuality write SetQuality;
  104.     property JPegSaveSmooth : Byte read GetSmooth write SetSmooth;
  105.     property UPdateBlobAsJpeg : Boolean read FUpdateAsJpeg write FUpdateAsJpeg;
  106.     property Align;
  107.     property AutoDisplay: Boolean read FAutoDisplay write SetAutoDisplay default True;
  108.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
  109.     property Center: Boolean read FCenter write SetCenter default True;
  110.     property Color;
  111.     property Ctl3D;
  112.     property DataField: string read GetDataField write SetDataField;
  113.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  114.     property DragCursor;
  115.     property DragMode;
  116.     property Enabled;
  117.     property Font;
  118.     property ParentColor default False;
  119.     property ParentCtl3D;
  120.     property ParentFont;
  121.     property ParentShowHint;
  122.     property PopupMenu;
  123.     property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
  124.     property ShowHint;
  125.     property Stretch: Boolean read FStretch write SetStretch default False;
  126.     property TabOrder;
  127.     property TabStop default True;
  128.     property Visible;
  129.     property OnClick;
  130.     property OnDblClick;
  131.     property OnDragDrop;
  132.     property OnDragOver;
  133.     property OnEndDrag;
  134.     property OnEnter;
  135.     property OnExit;
  136.     property OnKeyDown;
  137.     property OnKeyPress;
  138.     property OnKeyUp;
  139.     property OnMouseDown;
  140.     property OnMouseMove;
  141.     property OnMouseUp;
  142.   end;
  143.  
  144. {TDBMediaPlayer}
  145. Type
  146.   TDBMediaPlayer = class(TMediaPlayer)
  147.   {Just incase you/we want to add some stuff in the
  148.    future we derived a seperate object.}
  149. end;
  150.  
  151. {TDBMultiMedia }
  152. Type
  153.   TDBMultiMedia = class(TCustomControl)
  154.   private
  155.     FDataLink           :  TFieldDataLink;
  156.     FPicture            :  TPicture;
  157.     FBorderStyle        :  TBorderStyle;
  158.     FAutoDisplay        :  Boolean;
  159.     FStretch            :  Boolean;
  160.     FCenter             :  Boolean;
  161.     FPictureLoaded      :  Boolean;
  162.     FUpdateAsJpeg       :  Boolean;
  163.     FAutoPlayMM         :  Boolean;
  164.     FAutoMMHide         :  Boolean;
  165.     FAutoRePlayMM       :  Boolean;
  166.     FReserved           :  Byte;
  167.     Fdither             :  byte;
  168.     FResolution         :  byte;
  169.     FSaveQuality        :  byte;
  170.     FSaveSmooth         :  byte;
  171.     FMediaPlayer        :  TDBMediaPlayer;
  172.     FMOVTempFile        :  TFileName;
  173.     FMPGTempFile        :  TFileName;
  174.     FAVITempFile        :  TFileName;
  175.     FWAVTempFile        :  TFileName;
  176.     FMIDTempFile        :  TFileName;
  177.     FRMITempFile        :  TFileName;
  178.     FTempFilePath       :  String;
  179.     procedure DataChange(Sender: TObject);
  180.     function GetDataField: string;
  181.     function GetDataSource: TDataSource;
  182.     function GetMediaPlayer: TDBMediaPlayer;
  183.     function GetField: TField;
  184.     function GetReadOnly: Boolean;
  185.     procedure PictureChanged(Sender: TObject);
  186.     procedure SetAutoDisplay(Value: Boolean);
  187.     procedure SetBorderStyle(Value: TBorderStyle);
  188.     procedure SetCenter(Value: Boolean);
  189.     procedure SetDataField(const Value: string);
  190.     procedure SetDataSource(Value: TDataSource);
  191.     procedure SetMediaPlayer(Value: TDBMediaPlayer);
  192.     procedure SetPicture(Value: TPicture);
  193.     procedure SetReadOnly(Value: Boolean);
  194.     procedure SetStretch(Value: Boolean);
  195.     procedure UpdateData(Sender: TObject);
  196.     procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
  197.     procedure CMExit(var Message: TCMExit); message CM_EXIT;
  198.     procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
  199.     procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
  200.     procedure WMCut(var Message: TMessage); message WM_CUT;
  201.     procedure WMCopy(var Message: TMessage); message WM_COPY;
  202.     procedure WMPaste(var Message: TMessage); message WM_PASTE;
  203.     procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
  204.   protected
  205.     procedure CreateParams(var Params: TCreateParams); override;
  206.     function GetPalette: HPALETTE; override;
  207.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  208.     procedure KeyPress(var Key: Char); override;
  209.     procedure Notification(AComponent: TComponent;
  210.       Operation: TOperation); override;
  211.     procedure Paint; override;
  212.     function GetSmooth : Byte;
  213.     procedure SetSmooth(smooth : Byte);
  214.     function GetQuality : Byte;
  215.     procedure SetQuality(Quality : Byte);
  216.     function GetDither : Byte;
  217.     procedure SetDither(dith : Byte);
  218.     function GetRes : Byte;
  219.     procedure SetRes(res : Byte);
  220.     function GetTempPath : String;
  221.     procedure SetTempPath(temppath : string);
  222.     function AddBackSlash(DirName : string) : string;
  223.     function IsValidMultiMedia(Name : PChar) : boolean;
  224.     procedure TimerNotify(var Message: TMessage); message WM_TIMER;
  225.   public
  226.     BFiletype           :  String;
  227.     Bwidth              :  Integer;
  228.     BHeight             :  Integer;
  229.     Bbitspixel          :  Integer;
  230.     Bplanes             :  Integer;
  231.     Bnumcolors          :  Integer;
  232.     BSize               :  Longint;
  233.     Bcompression        :  String;
  234.     constructor Create(AOwner: TComponent); override;
  235.     destructor Destroy; override;
  236.     procedure CopyToClipboard;
  237.     procedure CutToClipboard;
  238.     procedure LoadMedia;
  239.     procedure PasteFromClipboard;
  240.     procedure LoadFromFile(filename : TFilename);
  241.     procedure SaveToFile(filename : TFilename);
  242.     procedure SaveToFileAsBMP(filename : TFilename);
  243.     procedure SaveToFileAsJpeg(filename : TFilename);
  244.     function GetInfoAndType : String;
  245.     function GetMultiMediaExtensions : String;
  246.     property Field: TField read GetField;
  247.     property Picture: TPicture read FPicture write SetPicture;
  248.   published
  249.     property JPegDither : Byte read GetDither write SetDither;
  250.     property JPegResolution : Byte read GetRes write SetRes;
  251.     property JPegSaveQuality : Byte read GetQuality write SetQuality;
  252.     property JPegSaveSmooth : Byte read GetSmooth write SetSmooth;
  253.     property UPdateBlobAsJpeg : Boolean read FUpdateAsJpeg write FUpdateAsJpeg;
  254.     property AutoPlayMultiMedia : Boolean read FAutoPlayMM write FAutoPlayMM;
  255.     property AutoRePlayMultiMedia : Boolean read FAutoRePlayMM write FAutoRePlayMM;
  256.     property AutoHideMediaPlayer : Boolean read FAutoMMHide write FAutoMMHide;
  257.     property PathForTempFile : string read GetTempPath write SetTempPath;
  258.     property Align;
  259.     property AutoDisplay: Boolean read FAutoDisplay write SetAutoDisplay default True;
  260.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
  261.     property Center: Boolean read FCenter write SetCenter default True;
  262.     property Color;
  263.     property Ctl3D;
  264.     property DataField: string read GetDataField write SetDataField;
  265.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  266.     property MediaPlayer: TDBMediaPlayer read GetMediaPlayer write SetmediaPlayer;
  267.     property DragCursor;
  268.     property DragMode;
  269.     property Enabled;
  270.     property Font;
  271.     property ParentColor default False;
  272.     property ParentCtl3D;
  273.     property ParentFont;
  274.     property ParentShowHint;
  275.     property PopupMenu;
  276.     property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
  277.     property ShowHint;
  278.     property Stretch: Boolean read FStretch write SetStretch default False;
  279.     property TabOrder;
  280.     property TabStop default True;
  281.     property Visible;
  282.     property OnClick;
  283.     property OnDblClick;
  284.     property OnDragDrop;
  285.     property OnDragOver;
  286.     property OnEndDrag;
  287.     property OnEnter;
  288.     property OnExit;
  289.     property OnKeyDown;
  290.     property OnKeyPress;
  291.     property OnKeyUp;
  292.     property OnMouseDown;
  293.     property OnMouseMove;
  294.     property OnMouseUp;
  295.   end;
  296.  
  297.  
  298.  
  299.  
  300. var
  301.  TMultiImageCallBack   : TCallBackFunction;
  302.  TDBMultiImageCallBack : TCallBackFunction;
  303.  TDBMultiMediaCallBack : TCallBackFunction;
  304.  
  305. {------------------------------------------------------------------------}
  306. implementation
  307. uses Consts, DBIErrs, DBITypes, Clipbrd, DBConsts, Dialogs;
  308.  
  309. {------------------------------------------------------------------------}
  310.  
  311. {TDBMultiImage}
  312. constructor TDBMultiImage.Create(AOwner: TComponent);
  313. begin
  314.   inherited Create(AOwner);
  315.   ControlStyle := ControlStyle + [csFramed, csOpaque];
  316.   Width := 105;
  317.   Height := 105;
  318.   TabStop := True;
  319.   ParentColor := False;
  320.   FPicture := TPicture.Create;
  321.   FPicture.OnChange := PictureChanged;
  322.   FBorderStyle := bsSingle;
  323.   FAutoDisplay := True;
  324.   FCenter := True;
  325.   FUpdateAsJpeg := True;
  326.   Fdither:=4;
  327.   FResolution:=8;
  328.   FSaveQuality:=25;
  329.   FSaveSmooth:=0;
  330.   FDataLink := TFieldDataLink.Create;
  331.   FDataLink.Control := Self;
  332.   FDataLink.OnDataChange := DataChange;
  333.   FDataLink.OnUpdateData := UpdateData;
  334. end;
  335. {------------------------------------------------------------------------}
  336.  
  337. destructor TDBMultiImage.Destroy;
  338. begin
  339.   FPicture.Free;
  340.   FDataLink.Free;
  341.   FDataLink := nil;
  342.   inherited Destroy;
  343. end;
  344. {------------------------------------------------------------------------}
  345.  
  346. function TDBMultiImage.GetDataSource: TDataSource;
  347. begin
  348.   Result := FDataLink.DataSource;
  349. end;
  350. {------------------------------------------------------------------------}
  351.  
  352. procedure TDBMultiImage.SetDataSource(Value: TDataSource);
  353. begin
  354.   FDataLink.DataSource := Value;
  355. end;
  356. {------------------------------------------------------------------------}
  357.  
  358. function TDBMultiImage.GetDataField: string;
  359. begin
  360.   Result := FDataLink.FieldName;
  361. end;
  362. {------------------------------------------------------------------------}
  363.  
  364. procedure TDBMultiImage.SetDataField(const Value: string);
  365. begin
  366.   FDataLink.FieldName := Value;
  367. end;
  368. {------------------------------------------------------------------------}
  369.  
  370. function TDBMultiImage.GetReadOnly: Boolean;
  371. begin
  372.   Result := FDataLink.ReadOnly;
  373. end;
  374. {------------------------------------------------------------------------}
  375.  
  376. procedure TDBMultiImage.SetReadOnly(Value: Boolean);
  377. begin
  378.   FDataLink.ReadOnly := Value;
  379. end;
  380. {------------------------------------------------------------------------}
  381.  
  382. function TDBMultiImage.GetField: TField;
  383. begin
  384.   Result := FDataLink.Field;
  385. end;
  386. {------------------------------------------------------------------------}
  387.  
  388. function TDBMultiImage.GetPalette: HPALETTE;
  389. begin
  390.   Result := 0;
  391.   if FPicture.Graphic is TBitmap then
  392.     Result := TBitmap(FPicture.Graphic).Palette;
  393. end;
  394. {------------------------------------------------------------------------}
  395.  
  396. procedure TDBMultiImage.SetAutoDisplay(Value: Boolean);
  397. begin
  398.   if FAutoDisplay <> Value then
  399.   begin
  400.     FAutoDisplay := Value;
  401.     if Value then LoadPicture;
  402.   end;
  403. end;
  404. {------------------------------------------------------------------------}
  405.  
  406. procedure TDBMultiImage.SetBorderStyle(Value: TBorderStyle);
  407. begin
  408.   if FBorderStyle <> Value then
  409.   begin
  410.     FBorderStyle := Value;
  411.     RecreateWnd;
  412.   end;
  413. end;
  414. {------------------------------------------------------------------------}
  415.  
  416. procedure TDBMultiImage.SetCenter(Value: Boolean);
  417. begin
  418.   if FCenter <> Value then
  419.   begin
  420.     FCenter := Value;
  421.     Invalidate;
  422.   end;
  423. end;
  424. {------------------------------------------------------------------------}
  425.  
  426. procedure TDBMultiImage.SetPicture(Value: TPicture);
  427. begin
  428.   FPicture.Assign(Value);
  429. end;
  430. {------------------------------------------------------------------------}
  431.  
  432. procedure TDBMultiImage.SetStretch(Value: Boolean);
  433. begin
  434.   if FStretch <> Value then
  435.   begin
  436.     FStretch := Value;
  437.     Invalidate;
  438.   end;
  439. end;
  440. {------------------------------------------------------------------------}
  441.  
  442. procedure TDBMultiImage.Paint;
  443. var
  444.   W, H: Integer;
  445.   R: TRect;
  446.   S: string[63];
  447. begin
  448.   with Canvas do
  449.   begin
  450.     Brush.Style := bsSolid;
  451.     Brush.Color := Color;
  452.     if FPictureLoaded then
  453.     begin
  454.       if Stretch then
  455.         if Picture.Graphic.Empty then
  456.           FillRect(ClientRect) else
  457.           StretchDraw(ClientRect, Picture.Graphic)
  458.       else
  459.       begin
  460.         SetRect(R, 0, 0, Picture.Width, Picture.Height);
  461.         if Center then OffsetRect(R, (ClientWidth - Picture.Width) div 2,
  462.           (ClientHeight - Picture.Height) div 2);
  463.         StretchDraw(R, Picture.Graphic);
  464.         ExcludeClipRect(Handle, R.Left, R.Top, R.Right, R.Bottom);
  465.         FillRect(ClientRect);
  466.         SelectClipRgn(Handle, 0);
  467.       end;
  468.     end else
  469.     begin
  470.       Font := Self.Font;
  471.       if FDataLink.Field <> nil then
  472.         S := FDataLink.Field.DisplayLabel else
  473.         S := Name;
  474.       S := '(' + S + ')';
  475.       W := TextWidth(S);
  476.       H := TextHeight(S);
  477.       R := ClientRect;
  478.       TextRect(R, (R.Right - W) div 2, (R.Bottom - H) div 2, S);
  479.     end;
  480.     if (GetParentForm(Self).ActiveControl = Self) and
  481.       not (csDesigning in ComponentState) then
  482.     begin
  483.       Brush.Color := clWindowFrame;
  484.       FrameRect(ClientRect);
  485.     end;
  486.   end;
  487. end;
  488. {------------------------------------------------------------------------}
  489.  
  490. procedure TDBMultiImage.PictureChanged(Sender: TObject);
  491. begin
  492.   FDataLink.Modified;
  493.   FPictureLoaded := True;
  494.   Invalidate;
  495. end;
  496. {------------------------------------------------------------------------}
  497.  
  498. procedure TDBMultiImage.Notification(AComponent: TComponent;
  499.   Operation: TOperation);
  500. begin
  501.   inherited Notification(AComponent, Operation);
  502.   if (Operation = opRemove) and (FDataLink <> nil) and
  503.     (AComponent = DataSource) then DataSource := nil;
  504. end;
  505. {------------------------------------------------------------------------}
  506.  
  507. procedure TDBMultiImage.LoadPicture;
  508. var
  509.    Stream       :  TMemoryStream;
  510.    BitMap       :  TBitMap;
  511.    Cursor       :  hCursor;
  512.    temp         :  string;
  513. begin
  514.   if not FPictureLoaded and (FDataLink.Field is TBlobField) then begin
  515.  
  516.    if TBlobField(FDataLink.Field).IsNull then exit;
  517.  
  518.    Temp:=GetInfoAndType;
  519.  
  520.    SendMessage(Canvas.Handle, WM_Paint, 0, 0);
  521.  
  522.  
  523.    if Temp = 'GIF' then begin
  524.       Stream:=TMemoryStream.Create;
  525.       BitMap:=TBitMap.Create;
  526.       try
  527.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  528.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  529.          if not gifblob(Stream.Memory,Stream.Size, Bitmap, TDBMultiImageCallBack) then begin
  530.             MessageDlg('Invallid or empty GIF blobfield', mtInformation, [mbOk], 0);
  531.             Picture.Assign(Nil);
  532.          end else
  533.             Picture.Assign(BitMap);
  534.          finally
  535.             SetCursor(Cursor);
  536.             BitMap.free;
  537.             Stream.Free;
  538.          end;
  539.    end else
  540.    if Temp = 'PCX' then begin
  541.       Stream:=TMemoryStream.Create;
  542.       BitMap:=TBitMap.Create;
  543.       try
  544.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  545.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  546.          if not pcxblob(Stream.Memory,Stream.Size, Bitmap, TDBMultiImageCallBack) then begin
  547.             MessageDlg('Invallid or empty PCX blobfield', mtInformation, [mbOk], 0);
  548.             Picture.Assign(Nil);
  549.          end else
  550.             Picture.Assign(BitMap);
  551.          finally
  552.           SetCursor(Cursor);
  553.           BitMap.free;
  554.           Stream.Free;
  555.          end;
  556.    end else
  557.    if Temp = 'BMP' then begin
  558.       Stream:=TMemoryStream.Create;
  559.       BitMap:=TBitMap.Create;
  560.       try
  561.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  562.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  563.          if not bmpblob(Stream.Memory,Stream.Size, Bitmap, TDBMultiImageCallBack) then begin
  564.             MessageDlg('Invallid or empty BMP blobfield', mtInformation, [mbOk], 0);
  565.             Picture.Assign(Nil);
  566.          end else
  567.             Picture.Assign(BitMap);
  568.          finally
  569.           SetCursor(Cursor);
  570.           BitMap.free;
  571.           Stream.Free;
  572.          end;
  573.    end else
  574.    if Temp = 'JPG' then begin
  575.       Stream:=TMemoryStream.Create;
  576.       BitMap:=TBitMap.Create;
  577.       if FResolution <> 4 then
  578.       if FResolution <> 8 then
  579.       if FResolution <> 24 then FResolution:=8;
  580.       if (FDither < 0) or (FDither > 4) then FDither:=4;
  581.       try
  582.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  583.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  584.          if not jpgblob(Stream.Memory,Stream.Size, FResolution, Fdither, Bitmap, TDBMultiImageCallBack) then begin
  585.             MessageDlg('Invallid or empty Jpeg Blobfield', mtInformation, [mbOk], 0);
  586.             Picture.Assign(Nil);
  587.          end else
  588.              Picture.Assign(BitMap);
  589.          finally
  590.              SetCursor(Cursor);
  591.              BitMap.free;
  592.              Stream.Free;
  593.          end;
  594.     end;
  595.     GetInfoAndType;
  596.  end;
  597. end;
  598. {------------------------------------------------------------------------}
  599.  
  600. procedure TDBMultiImage.DataChange(Sender: TObject);
  601. begin
  602.   Picture.Graphic := nil;
  603.   FPictureLoaded := False;
  604.   if FAutoDisplay then LoadPicture;
  605. end;
  606. {------------------------------------------------------------------------}
  607.  
  608. procedure TDBMultiImage.UpdateData(Sender: TObject);
  609. var
  610.    Stream       :  TMemoryStream;
  611.    Cursor       :  hCursor;
  612.    Usize        :  longInt;
  613.    x,y          :  longInt;
  614.    p            :  Pointer;
  615. begin
  616.   if FDataLink.Field is TBlobField then begin
  617.  
  618.     if Picture.Graphic is TBitmap then begin
  619.       x:=Picture.BitMap.Width;
  620.       y:=Picture.BitMap.Height;
  621.  
  622.       y:=y+(y div 5);
  623.       x:=x+(x div 5);
  624.  
  625.       Usize:=(y * x);
  626.  
  627.       if Usize < 90000 then Usize:=Usize*2;
  628.  
  629.       {Since we can't know how much memory we need to allocate
  630.       to write the picture to the stream we need to guess it. This
  631.       is done using the width and height of the bitmap. After the call
  632.       to the dll using PUTJPGBLOB or PUTBMPBLOB Usize contains the
  633.       correct size of the Jpeg stored in P^. You can increase or decrease
  634.       the guessed memory by altering the Div by. For instance
  635.  
  636.       y:=y+(y div 3);
  637.       x:=x+(x div 3);
  638.  
  639.       will allocate more memory then
  640.  
  641.       y:=y+(y div 6);
  642.       x:=x+(x div 6);
  643.  
  644.       We played it on the save side. Use this "guess work" very carefully}
  645.  
  646.  
  647.       P := GlobalAllocPtr(HeapAllocFlags, Usize);
  648.       if P = Nil then begin
  649.         MessageDlg('Error allocation blob memory', mtInformation, [mbOk], 0);
  650.         exit;
  651.       end;
  652.  
  653.       if FUpdateAsJpeg then begin
  654.          if not putjpgblob(P, USize, FSaveQuality, FSaveSmooth, Picture.Bitmap, TDBMultiImageCallBack) then
  655.            MessageDlg('Jpeg BLOB Write Error', mtInformation, [mbOk], 0);
  656.       end else begin
  657.          if not putbmpblob(P, USize, Picture.Bitmap, TDBMultiImageCallBack) then
  658.            MessageDlg('BMP BLOB Write Error', mtInformation, [mbOk], 0);
  659.       end;
  660.  
  661.       Stream:=TMemoryStream.Create;
  662.       Stream.Write(P^,USize);
  663.       GlobalFreePtr(P);
  664.  
  665.       try
  666.         TBlobField(FDataLink.Field).LoadFromStream(Stream);
  667.       finally
  668.         Stream.Free;
  669.       end;
  670.  
  671.     end else
  672.       TBlobField(FDataLink.Field).Clear;
  673.    end;
  674.    GetInfoAndType;
  675. end;
  676. {------------------------------------------------------------------------}
  677.  
  678. procedure TDBMultiImage.CopyToClipboard;
  679. begin
  680.   if Picture.Graphic <> nil then Clipboard.Assign(Picture);
  681. end;
  682. {------------------------------------------------------------------------}
  683.  
  684. procedure TDBMultiImage.CutToClipboard;
  685. begin
  686.   if Picture.Graphic <> nil then
  687.   begin
  688.     CopyToClipboard;
  689.     if FDataLink.Edit then
  690.       Picture.Graphic := nil;
  691.   end;
  692. end;
  693. {------------------------------------------------------------------------}
  694.  
  695. procedure TDBMultiImage.PasteFromClipboard;
  696. begin
  697.   if Clipboard.HasFormat(CF_PICTURE) and FDataLink.Edit then
  698.     Picture.Assign(Clipboard);
  699. end;
  700. {------------------------------------------------------------------------}
  701.  
  702. procedure TDBMultiImage.CreateParams(var Params: TCreateParams);
  703. begin
  704.   inherited CreateParams(Params);
  705.   if FBorderStyle = bsSingle then
  706.     Params.Style := Params.Style or WS_BORDER;
  707. end;
  708. {------------------------------------------------------------------------}
  709.  
  710. procedure TDBMultiImage.KeyDown(var Key: Word; Shift: TShiftState);
  711. begin
  712.   inherited KeyDown(Key, Shift);
  713.   case Key of
  714.     VK_INSERT:
  715.       if ssShift in Shift then PasteFromClipBoard else
  716.         if ssCtrl in Shift then CopyToClipBoard;
  717.     VK_DELETE:
  718.       if ssShift in Shift then CutToClipBoard;
  719.   end;
  720. end;
  721. {------------------------------------------------------------------------}
  722.  
  723. procedure TDBMultiImage.KeyPress(var Key: Char);
  724. begin
  725.   inherited KeyPress(Key);
  726.   case Key of
  727.     ^X: CutToClipBoard;
  728.     ^C: CopyToClipBoard;
  729.     ^V: PasteFromClipBoard;
  730.     #13: LoadPicture;
  731.     #27: FDataLink.Reset;
  732.   end;
  733. end;
  734. {------------------------------------------------------------------------}
  735.  
  736. procedure TDBMultiImage.CMEnter(var Message: TCMEnter);
  737. begin
  738.   Invalidate; { Draw the focus marker }
  739.   inherited;
  740. end;
  741. {------------------------------------------------------------------------}
  742.  
  743. procedure TDBMultiImage.CMExit(var Message: TCMExit);
  744. begin
  745.   Invalidate; { Erase the focus marker }
  746.   inherited;
  747. end;
  748. {------------------------------------------------------------------------}
  749.  
  750. procedure TDBMultiImage.CMTextChanged(var Message: TMessage);
  751. begin
  752.   inherited;
  753.   if not FPictureLoaded then Invalidate;
  754. end;
  755. {------------------------------------------------------------------------}
  756.  
  757. procedure TDBMultiImage.WMLButtonDown(var Message: TWMLButtonDown);
  758. begin
  759.   if TabStop and CanFocus then SetFocus;
  760.   inherited;
  761. end;
  762. {------------------------------------------------------------------------}
  763.  
  764. procedure TDBMultiImage.WMLButtonDblClk(var Message: TWMLButtonDblClk);
  765. begin
  766.   LoadPicture;
  767.   inherited;
  768. end;
  769. {------------------------------------------------------------------------}
  770.  
  771. procedure TDBMultiImage.WMCut(var Message: TMessage);
  772. begin
  773.   CutToClipboard;
  774. end;
  775. {------------------------------------------------------------------------}
  776.  
  777. procedure TDBMultiImage.WMCopy(var Message: TMessage);
  778. begin
  779.   CopyToClipboard;
  780. end;
  781. {------------------------------------------------------------------------}
  782.  
  783. procedure TDBMultiImage.WMPaste(var Message: TMessage);
  784. begin
  785.   PasteFromClipboard;
  786. end;
  787. {------------------------------------------------------------------------}
  788.  
  789. procedure TDBMultiImage.LoadFromFile(filename : TFilename);
  790. var
  791.    Cursor       :  hCursor;
  792. begin
  793.  
  794.   if not FileExists(filename) then begin
  795.     MessageDlg('File not found', mtInformation, [mbOk], 0);
  796.     exit;
  797.   end;
  798.  
  799.   if UpperCase(ExtractFileExt(filename)) <> '.JPG' then
  800.   if UpperCase(ExtractFileExt(filename)) <> '.GIF' then
  801.   if UpperCase(ExtractFileExt(filename)) <> '.PCX' then
  802.   if UpperCase(ExtractFileExt(filename)) <> '.BMP' then
  803.   begin
  804.     MessageDlg('Not a Jpeg, Gif, Pcx or Bmp File', mtInformation, [mbOk], 0);
  805.     exit;
  806.   end;
  807.  
  808.   Cursor := SetCursor(LoadCursor(0,idc_Wait));
  809.  
  810.   if FDataLink.Field is TBlobField then
  811.     TBlobField(FDataLink.Field).LoadFromFile(filename)
  812.   else begin
  813.     SetCursor(Cursor);
  814.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  815.     exit;
  816.   end;
  817.   GetInfoAndType;
  818.   SetCursor(Cursor);
  819. end;
  820. {------------------------------------------------------------------------}
  821.  
  822. procedure TDBMultiImage.SaveToFile(filename : TFilename);
  823. var
  824.   Cursor       :  hCursor;
  825. begin
  826.   if FDataLink.Field is TBlobField then begin
  827.  
  828.     if TBlobField(FDataLink.Field).IsNull then begin
  829.        MessageDlg('Can''t save, blobfield is empty', mtInformation, [mbOk], 0);
  830.        exit;
  831.     end;
  832.  
  833.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  834.     TBlobField(FDataLink.Field).SaveToFile(filename);
  835.     GetInfoAndType;
  836.     SetCursor(Cursor)
  837.  
  838.   end else begin
  839.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  840.     exit;
  841.   end;
  842. end;
  843. {------------------------------------------------------------------------}
  844.  
  845. procedure TDBMultiImage.SaveToFileAsBMP(filename : TFilename);
  846. var
  847.   Cursor       :  hCursor;
  848. begin
  849.   if FDataLink.Field is TBlobField then begin
  850.  
  851.     if TBlobField(FDataLink.Field).IsNull then begin
  852.        MessageDlg('Can''t save, blobfield bitmap is empty', mtInformation, [mbOk], 0);
  853.        exit;
  854.     end;
  855.  
  856.     if picture.bitmap.empty then begin
  857.        MessageDlg('Can''t save, image is not displayed, Set Autodisplay or double click display to view image first.',
  858.                   mtInformation, [mbOk], 0);
  859.        exit;
  860.     end;
  861.  
  862.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  863.  
  864.     if not putbmpfile(FileName, picture.Bitmap, TDBMultiImageCallBack) then begin
  865.       SetCursor(Cursor);
  866.       MessageDlg('Writing bmp file failed', mtInformation, [mbOk], 0);
  867.       exit;
  868.     end;
  869.  
  870.     GetInfoAndType
  871.  
  872.   end else begin
  873.     SetCursor(Cursor);
  874.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  875.     exit;
  876.   end;
  877.  
  878.   SetCursor(Cursor);
  879. end;
  880. {------------------------------------------------------------------------}
  881.  
  882. procedure TDBMultiImage.SaveToFileAsJpeg(filename : TFilename);
  883. var
  884.   Cursor       :  hCursor;
  885. begin
  886.   if FDataLink.Field is TBlobField then begin
  887.  
  888.     if TBlobField(FDataLink.Field).IsNull then begin
  889.        MessageDlg('Can''t save, blobfield bitmap is empty', mtInformation, [mbOk], 0);
  890.        exit;
  891.     end;
  892.  
  893.     if picture.bitmap = nil then begin
  894.        MessageDlg('Can''t save, image is not displayed', mtInformation, [mbOk], 0);
  895.        exit;
  896.     end;
  897.  
  898.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  899.  
  900.     if not putjpgfile(FileName, FSaveQuality, FSaveSmooth, picture.Bitmap, TDBMultiImageCallBack) then begin
  901.       SetCursor(Cursor);
  902.       MessageDlg('Writing jpg file failed', mtInformation, [mbOk], 0);
  903.       exit;
  904.     end;
  905.  
  906.     GetInfoAndType
  907.  
  908.   end else begin
  909.     SetCursor(Cursor);
  910.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  911.     exit;
  912.   end;
  913.  
  914.   SetCursor(Cursor);
  915. end;
  916.  
  917.  
  918. {------------------------------------------------------------------------}
  919.  
  920. function TDBMultiImage.GetInfoAndType : String;
  921. var
  922.  Stream       :  TMemoryStream;
  923. begin
  924.   if (FDataLink.Field is TBlobField) then
  925.    if TBlobField(FDataLink.Field).IsNull then exit;
  926.  
  927.    BFileType := 'Empty';
  928.    Bwidth:=-1;
  929.    BHeight:=-1;
  930.    Bbitspixel:=-1;
  931.    Bplanes:=-1;
  932.    Bnumcolors:=-1;
  933.    Bcompression:='-1';
  934.    BSize:=-1;
  935.    GetInfoAndType :='-1';
  936.  
  937.    Stream:=TMemoryStream.Create;
  938.    TBlobField(FDataLink.Field).SaveToStream(Stream);
  939.    if not GetBlobInfo(Stream.Memory,
  940.                     Stream.Size,
  941.                     BFileType,
  942.                     Bwidth,
  943.                     BHeight,
  944.                     Bbitspixel,
  945.                     Bplanes,
  946.                     Bnumcolors,
  947.                     Bcompression) then
  948.     MessageDlg('blobfield getinfo failed', mtInformation, [mbOk], 0) else
  949.     begin
  950.          BSize:=Stream.Size;
  951.          if UpperCase(BFileType) = 'GIF' then GetInfoAndType:='GIF' else
  952.          if UpperCase(BFileType) = 'PCX' then GetInfoAndType:='PCX' else
  953.          if UpperCase(BFileType) = 'JPEG' then GetInfoAndType:='JPG' else
  954.          if UpperCase(BFileType) = 'BMP' then GetInfoAndType:='BMP';
  955.     end;
  956.   if Stream.Memory <> nil then Stream.Free;
  957. end;
  958. {------------------------------------------------------------------------}
  959.  
  960. function TDBMultiImage.GetSmooth : Byte;
  961. begin
  962.   GetSmooth:=FSaveSmooth;
  963. end;
  964. {------------------------------------------------------------------------}
  965.  
  966. procedure TDBMultiImage.SetSmooth(Smooth : Byte);
  967. begin
  968.   if (Smooth > 100) or (Smooth < 0) then FSaveSmooth:=5 else
  969.    FSaveSmooth:=Smooth;
  970. end;
  971. {------------------------------------------------------------------------}
  972.  
  973. function TDBMultiImage.GetQuality : Byte;
  974. begin
  975.   GetQuality:=FSaveQuality;
  976. end;
  977. {------------------------------------------------------------------------}
  978.  
  979. procedure TDBMultiImage.SetQuality(Quality : Byte);
  980. begin
  981.   if (Quality > 100) OR (Quality < 1) then FSaveQuality:=25 else
  982.    FSaveQuality:=Quality;
  983. end;
  984. {------------------------------------------------------------------------}
  985. function TDBMultiImage.GetDither : Byte;
  986. begin
  987.   GetDither:=Fdither
  988. end;
  989. {------------------------------------------------------------------------}
  990.  
  991. procedure TDBMultiImage.SetDither(dith : Byte);
  992. begin
  993.   Fdither:=4;
  994.   case dith of
  995.             0..4 :Fdither:=dith;
  996.   end;
  997. end;
  998. {------------------------------------------------------------------------}
  999.  
  1000. function TDBMultiImage.GetRes : Byte;
  1001. begin
  1002.   GetRes:=FResolution;
  1003. end;
  1004. {------------------------------------------------------------------------}
  1005.  
  1006.  
  1007. procedure TDBMultiImage.SetRes(res : Byte);
  1008. begin
  1009.   FResolution:=8;
  1010.   case res of
  1011.             4 :FResolution:=res;
  1012.             8 :FResolution:=res;
  1013.             24:FResolution:=res;
  1014.   end;
  1015. end;
  1016. {------------------------------------------------------------------------}
  1017. {TDBMultiMedia}
  1018. constructor TDBMultiMedia.Create(AOwner: TComponent);
  1019. begin
  1020.   inherited Create(AOwner);
  1021.   ControlStyle := ControlStyle + [csFramed, csOpaque];
  1022.   Width := 105;
  1023.   Height := 105;
  1024.   TabStop := True;
  1025.   ParentColor := False;
  1026.   FPicture := TPicture.Create;
  1027.   FPicture.OnChange := PictureChanged;
  1028.   FBorderStyle := bsSingle;
  1029.   FAutoDisplay := True;
  1030.   FCenter := True;
  1031.   FUpdateAsJpeg := True;
  1032.   Fdither:=4;
  1033.   FResolution:=8;
  1034.   FSaveQuality:=25;
  1035.   FSaveSmooth:=0;
  1036.   FDataLink := TFieldDataLink.Create;
  1037.   FDataLink.Control := Self;
  1038.   FDataLink.OnDataChange := DataChange;
  1039.   FDataLink.OnUpdateData := UpdateData;
  1040.   FMOVTempFile:='$$$.MOV';
  1041.   FMPGTempFile:='$$$.MPG';
  1042.   FAVITempFile:='$$$.AVI';
  1043.   FWAVTempFile:='$$$.WAV';
  1044.   FMIDTempFile:='$$$.MID';
  1045.   FRMITempFile:='$$$.RMI';
  1046.   FTempFilePath:='C:\';
  1047. end;
  1048. {------------------------------------------------------------------------}
  1049.  
  1050. destructor TDBMultiMedia.Destroy;
  1051. begin
  1052.   FPicture.Free;
  1053.   FDataLink.Free;
  1054.   FDataLink := nil;
  1055.   inherited Destroy;
  1056. end;
  1057. {------------------------------------------------------------------------}
  1058.  
  1059. function TDBMultiMedia.GetDataSource: TDataSource;
  1060. begin
  1061.   Result := FDataLink.DataSource;
  1062. end;
  1063. {------------------------------------------------------------------------}
  1064.  
  1065. procedure TDBMultiMedia.SetDataSource(Value: TDataSource);
  1066. begin
  1067.   FDataLink.DataSource := Value;
  1068. end;
  1069. {------------------------------------------------------------------------}
  1070.  
  1071. function TDBMultiMedia.GetDataField: string;
  1072. begin
  1073.   Result := FDataLink.FieldName;
  1074. end;
  1075. {------------------------------------------------------------------------}
  1076.  
  1077. procedure TDBMultiMedia.SetDataField(const Value: string);
  1078. begin
  1079.   FDataLink.FieldName := Value;
  1080. end;
  1081. {------------------------------------------------------------------------}
  1082.  
  1083. function TDBMultiMedia.GetReadOnly: Boolean;
  1084. begin
  1085.   Result := FDataLink.ReadOnly;
  1086. end;
  1087. {------------------------------------------------------------------------}
  1088.  
  1089. procedure TDBMultiMedia.SetReadOnly(Value: Boolean);
  1090. begin
  1091.   FDataLink.ReadOnly := Value;
  1092. end;
  1093. {------------------------------------------------------------------------}
  1094.  
  1095. function TDBMultiMedia.GetField: TField;
  1096. begin
  1097.   Result := FDataLink.Field;
  1098. end;
  1099. {------------------------------------------------------------------------}
  1100.  
  1101. function TDBMultiMedia.GetPalette: HPALETTE;
  1102. begin
  1103.   Result := 0;
  1104.   if FPicture.Graphic is TBitmap then
  1105.     Result := TBitmap(FPicture.Graphic).Palette;
  1106. end;
  1107. {------------------------------------------------------------------------}
  1108.  
  1109. procedure TDBMultiMedia.SetAutoDisplay(Value: Boolean);
  1110. begin
  1111.   if FAutoDisplay <> Value then
  1112.   begin
  1113.     FAutoDisplay := Value;
  1114.     if Value then LoadMedia;
  1115.   end;
  1116. end;
  1117. {------------------------------------------------------------------------}
  1118.  
  1119. procedure TDBMultiMedia.SetBorderStyle(Value: TBorderStyle);
  1120. begin
  1121.   if FBorderStyle <> Value then
  1122.   begin
  1123.     FBorderStyle := Value;
  1124.     RecreateWnd;
  1125.   end;
  1126. end;
  1127. {------------------------------------------------------------------------}
  1128.  
  1129. procedure TDBMultiMedia.SetCenter(Value: Boolean);
  1130. begin
  1131.   if FCenter <> Value then
  1132.   begin
  1133.     FCenter := Value;
  1134.     Invalidate;
  1135.   end;
  1136. end;
  1137. {------------------------------------------------------------------------}
  1138.  
  1139. procedure TDBMultiMedia.SetPicture(Value: TPicture);
  1140. begin
  1141.   FPicture.Assign(Value);
  1142. end;
  1143. {------------------------------------------------------------------------}
  1144.  
  1145. procedure TDBMultiMedia.SetStretch(Value: Boolean);
  1146. begin
  1147.   if FStretch <> Value then
  1148.   begin
  1149.     FStretch := Value;
  1150.     Invalidate;
  1151.   end;
  1152. end;
  1153. {------------------------------------------------------------------------}
  1154.  
  1155. procedure TDBMultiMedia.Paint;
  1156. var
  1157.   W, H: Integer;
  1158.   R: TRect;
  1159.   S: string[63];
  1160. begin
  1161.   with Canvas do
  1162.   begin
  1163.     Brush.Style := bsSolid;
  1164.     Brush.Color := Color;
  1165.     if FPictureLoaded then
  1166.     begin
  1167.       if Stretch then
  1168.         if Picture.Graphic.Empty then
  1169.           FillRect(ClientRect) else
  1170.           StretchDraw(ClientRect, Picture.Graphic)
  1171.       else
  1172.       begin
  1173.         SetRect(R, 0, 0, Picture.Width, Picture.Height);
  1174.         if Center then OffsetRect(R, (ClientWidth - Picture.Width) div 2,
  1175.           (ClientHeight - Picture.Height) div 2);
  1176.         StretchDraw(R, Picture.Graphic);
  1177.         ExcludeClipRect(Handle, R.Left, R.Top, R.Right, R.Bottom);
  1178.         FillRect(ClientRect);
  1179.         SelectClipRgn(Handle, 0);
  1180.       end;
  1181.     end else
  1182.     begin
  1183.       Font := Self.Font;
  1184.       if FDataLink.Field <> nil then
  1185.         S := FDataLink.Field.DisplayLabel else
  1186.         S := Name;
  1187.       S := '(' + S + ')';
  1188.       W := TextWidth(S);
  1189.       H := TextHeight(S);
  1190.       R := ClientRect;
  1191.       TextRect(R, (R.Right - W) div 2, (R.Bottom - H) div 2, S);
  1192.     end;
  1193.     if (GetParentForm(Self).ActiveControl = Self) and
  1194.       not (csDesigning in ComponentState) then
  1195.     begin
  1196.       Brush.Color := clWindowFrame;
  1197.       FrameRect(ClientRect);
  1198.     end;
  1199.   end;
  1200. end;
  1201. {------------------------------------------------------------------------}
  1202.  
  1203. procedure TDBMultiMedia.PictureChanged(Sender: TObject);
  1204. begin
  1205.   FDataLink.Modified;
  1206.   FPictureLoaded := True;
  1207.   Invalidate;
  1208. end;
  1209. {------------------------------------------------------------------------}
  1210.  
  1211. procedure TDBMultiMedia.Notification(AComponent: TComponent;
  1212.   Operation: TOperation);
  1213. begin
  1214.   inherited Notification(AComponent, Operation);
  1215.   if (Operation = opRemove) and (FDataLink <> nil) and
  1216.     (AComponent = DataSource) then DataSource := nil;
  1217.  
  1218.   if (Operation = opRemove) and
  1219.     (AComponent = FMediaPlayer) then FMediaPlayer := nil;
  1220. end;
  1221. {------------------------------------------------------------------------}
  1222.  
  1223. procedure TDBMultiMedia.LoadMedia;
  1224. var
  1225.    Stream       :  TMemoryStream;
  1226.    BitMap       :  TBitMap;
  1227.    Cursor       :  hCursor;
  1228.    temp         :  string;
  1229. begin
  1230.   if not FPictureLoaded and (FDataLink.Field is TBlobField) then begin
  1231.  
  1232.    if TBlobField(FDataLink.Field).IsNull then exit;
  1233.  
  1234.    Temp:=GetInfoAndType;
  1235.  
  1236.    deletefile(FTempFilePath+FMPGTempFile);
  1237.    deletefile(FTempFilePath+FMOVTempFile);
  1238.    deletefile(FTempFilePath+FAVITempFile);
  1239.    deletefile(FTempFilePath+FWAVTempFile);
  1240.    deletefile(FTempFilePath+FMIDTempFile);
  1241.    deletefile(FTempFilePath+FRMITempFile);
  1242.  
  1243.   if FMediaPlayer <> nil then
  1244.      FMediaPlayer.Close;
  1245.  
  1246.   if Temp = 'MPG' then begin
  1247.          try
  1248.             if (csDesigning in ComponentState) then exit;
  1249.  
  1250.             if not IsValidMultiMedia('MPG') then exit;
  1251.               Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1252.               if FMediaPlayer <> nil then begin
  1253.                FMediaPlayer.Visible:=true;
  1254.                TBlobField(FDataLink.Field).SaveToFile(FTempFilePath+FMPGTempFile);
  1255.                FMediaPlayer.FileName:=FTempFilePath+FMPGTempFile;
  1256.                FMediaPlayer.Open;
  1257.                if FAutoPlayMM then
  1258.                  FMediaPlayer.Play;
  1259.                SetTimer(handle,1,500,nil);
  1260.             end;
  1261.          finally
  1262.             SetCursor(Cursor);
  1263.          end;
  1264.    end else
  1265.  
  1266.    if Temp = 'MOV' then begin
  1267.          try
  1268.             if (csDesigning in ComponentState) then exit;
  1269.  
  1270.             if not IsValidMultiMedia('MOV') then exit;
  1271.               Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1272.               if FMediaPlayer <> nil then begin
  1273.                FMediaPlayer.Visible:=true;
  1274.                TBlobField(FDataLink.Field).SaveToFile(FTempFilePath+FMOVTempFile);
  1275.                FMediaPlayer.FileName:=FTempFilePath+FMOVTempFile;
  1276.                FMediaPlayer.Open;
  1277.                if FAutoPlayMM then
  1278.                  FMediaPlayer.Play;
  1279.                SetTimer(handle,1,500,nil);
  1280.             end;
  1281.          finally
  1282.             SetCursor(Cursor);
  1283.          end;
  1284.    end else
  1285.  
  1286.    if Temp = 'AVI' then begin
  1287.          try
  1288.             if (csDesigning in ComponentState) then exit;
  1289.  
  1290.             if not IsValidMultiMedia('AVI') then exit;
  1291.             Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1292.               if FMediaPlayer <> nil then begin
  1293.                FMediaPlayer.Visible:=true;
  1294.                TBlobField(FDataLink.Field).SaveToFile(FTempFilePath+FAVITempFile);
  1295.                FMediaPlayer.FileName:=FTempFilePath+FAVITempFile;
  1296.                FMediaPlayer.Open;
  1297.                if FAutoPlayMM then
  1298.                  FMediaPlayer.Play;
  1299.                SetTimer(handle,1,500,nil);
  1300.             end;
  1301.          finally
  1302.             SetCursor(Cursor);
  1303.          end;
  1304.    end else
  1305.  
  1306.    if Temp = 'WAV' then begin
  1307.          try
  1308.             if (csDesigning in ComponentState) then exit;
  1309.  
  1310.             if not IsValidMultiMedia('WAV') then exit;
  1311.             Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1312.             if FMediaPlayer <> nil then begin
  1313.                FMediaPlayer.Visible:=true;
  1314.                TBlobField(FDataLink.Field).SaveToFile(FTempFilePath+FWAVTempFile);
  1315.                FMediaPlayer.FileName:=FTempFilePath+FWAVTempFile;
  1316.                FMediaPlayer.Open;
  1317.                if FAutoPlayMM then
  1318.                  FMediaPlayer.Play;
  1319.                SetTimer(handle,1,500,nil);
  1320.             end;
  1321.          finally
  1322.             SetCursor(Cursor);
  1323.          end;
  1324.    end else
  1325.  
  1326.    if Temp = 'MID' then begin
  1327.          try
  1328.             if (csDesigning in ComponentState) then exit;
  1329.  
  1330.             if not IsValidMultiMedia('MID') then exit;
  1331.             Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1332.             if FMediaPlayer <> nil then begin
  1333.                FMediaPlayer.Visible:=true;
  1334.                TBlobField(FDataLink.Field).SaveToFile(FTempFilePath+FMIDTempFile);
  1335.                FMediaPlayer.FileName:=FTempFilePath+FMIDTempFile;
  1336.                FMediaPlayer.Open;
  1337.                if FAutoPlayMM then
  1338.                  FMediaPlayer.Play;
  1339.                SetTimer(handle,1,500,nil);
  1340.             end;
  1341.          finally
  1342.             SetCursor(Cursor);
  1343.          end;
  1344.    end else
  1345.  
  1346.    if Temp = 'RMI' then begin
  1347.          try
  1348.             if (csDesigning in ComponentState) then exit;
  1349.  
  1350.             if not IsValidMultiMedia('RMI') then exit;
  1351.             Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1352.             if FMediaPlayer <> nil then begin
  1353.                FMediaPlayer.Visible:=true;
  1354.                TBlobField(FDataLink.Field).SaveToFile(FTempFilePath+FRMITempFile);
  1355.                FMediaPlayer.FileName:=FTempFilePath+FRMITempFile;
  1356.                FMediaPlayer.Open;
  1357.                if FAutoPlayMM then
  1358.                  FMediaPlayer.Play;
  1359.                SetTimer(handle,1,500,nil);
  1360.             end;
  1361.          finally
  1362.             SetCursor(Cursor);
  1363.          end;
  1364.    end else
  1365.  
  1366.    if Temp = 'GIF' then begin
  1367.       Stream:=TMemoryStream.Create;
  1368.       BitMap:=TBitMap.Create;
  1369.       try
  1370.        if FMediaPlayer <> nil then
  1371.          if FAutoMMHide then
  1372.            FMediaPlayer.Visible:=False;
  1373.          KillTimer(handle,1);
  1374.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  1375.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1376.          if not gifblob(Stream.Memory,Stream.Size, Bitmap, TDBMultiMediaCallBack) then begin
  1377.             MessageDlg('Invallid or empty GIF blobfield', mtInformation, [mbOk], 0);
  1378.             Picture.Assign(Nil);
  1379.          end else
  1380.             Picture.Assign(BitMap);
  1381.          finally
  1382.             SetCursor(Cursor);
  1383.             BitMap.free;
  1384.             Stream.Free;
  1385.          end;
  1386.    end else
  1387.  
  1388.    if Temp = 'PCX' then begin
  1389.       Stream:=TMemoryStream.Create;
  1390.       BitMap:=TBitMap.Create;
  1391.       try
  1392.        if FMediaPlayer <> nil then
  1393.          if FAutoMMHide then
  1394.            FMediaPlayer.Visible:=False;
  1395.          KillTimer(handle,1);
  1396.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  1397.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1398.          if not pcxblob(Stream.Memory,Stream.Size, Bitmap, TDBMultiMediaCallBack) then begin
  1399.             MessageDlg('Invallid or empty PCX blobfield', mtInformation, [mbOk], 0);
  1400.             Picture.Assign(Nil);
  1401.          end else
  1402.             Picture.Assign(BitMap);
  1403.          finally
  1404.           SetCursor(Cursor);
  1405.           BitMap.free;
  1406.           Stream.Free;
  1407.          end;
  1408.    end else
  1409.  
  1410.    if Temp = 'BMP' then begin
  1411.       Stream:=TMemoryStream.Create;
  1412.       BitMap:=TBitMap.Create;
  1413.       try
  1414.        if FMediaPlayer <> nil then
  1415.          if FAutoMMHide then
  1416.            FMediaPlayer.Visible:=False;
  1417.          KillTimer(handle,1);
  1418.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  1419.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1420.          if not bmpblob(Stream.Memory,Stream.Size, Bitmap, TDBMultiMediaCallBack) then begin
  1421.             MessageDlg('Invallid or empty BMP blobfield', mtInformation, [mbOk], 0);
  1422.             Picture.Assign(Nil);
  1423.          end else
  1424.             Picture.Assign(BitMap);
  1425.          finally
  1426.           SetCursor(Cursor);
  1427.           BitMap.free;
  1428.           Stream.Free;
  1429.          end;
  1430.    end else
  1431.  
  1432.    if Temp = 'JPG' then begin
  1433.       Stream:=TMemoryStream.Create;
  1434.       BitMap:=TBitMap.Create;
  1435.       if FResolution <> 4 then
  1436.       if FResolution <> 8 then
  1437.       if FResolution <> 24 then FResolution:=8;
  1438.       if (FDither < 0) or (FDither > 4) then FDither:=4;
  1439.       try
  1440.        if FMediaPlayer <> nil then
  1441.          if FAutoMMHide then
  1442.            FMediaPlayer.Visible:=False;
  1443.          KillTimer(handle,1);
  1444.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  1445.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1446.  
  1447.          if not jpgblob(Stream.Memory,Stream.Size, FResolution, Fdither, Bitmap, TDBMultiMediaCallBack) then begin
  1448.             MessageDlg('Invallid or empty Jpeg Blobfield', mtInformation, [mbOk], 0);
  1449.             Picture.Assign(Nil);
  1450.          end else
  1451.              Picture.Assign(BitMap);
  1452.          finally
  1453.              SetCursor(Cursor);
  1454.              BitMap.free;
  1455.              Stream.Free;
  1456.          end;
  1457.     end;
  1458.     {GetInfoAndType;}
  1459.  end;
  1460. end;
  1461. {------------------------------------------------------------------------}
  1462.  
  1463. procedure TDBMultiMedia.DataChange(Sender: TObject);
  1464. begin
  1465.   Picture.Graphic := nil;
  1466.   FPictureLoaded := False;
  1467.   if FAutoDisplay then LoadMedia;
  1468. end;
  1469. {------------------------------------------------------------------------}
  1470.  
  1471. procedure TDBMultiMedia.UpdateData(Sender: TObject);
  1472. var
  1473.    Stream       :  TMemoryStream;
  1474.    Cursor       :  hCursor;
  1475.    Usize        :  longInt;
  1476.    x,y          :  longInt;
  1477.    p            :  Pointer;
  1478. begin
  1479.   if FDataLink.Field is TBlobField then begin
  1480.  
  1481.     if Picture.Graphic is TBitmap then begin
  1482.       x:=Picture.BitMap.Width;
  1483.       y:=Picture.BitMap.Height;
  1484.  
  1485.       y:=y+(y div 5);
  1486.       x:=x+(x div 5);
  1487.  
  1488.       Usize:=(y * x);
  1489.  
  1490.       if Usize < 90000 then Usize:=Usize*2;
  1491.  
  1492.       {Since we can't know how much memory we need to allocate
  1493.       to write the picture to the stream we need to guess it. This
  1494.       is done using the width and height of the bitmap. After the call
  1495.       to the dll using PUTJPGBLOB or PUTBMPBLOB Usize contains the
  1496.       correct size of the Bitmap stored in P^. You can increase or decrease
  1497.       the guessed memory by altering the Div by. For instance
  1498.  
  1499.       y:=y+(y div 3);
  1500.       x:=x+(x div 3);
  1501.  
  1502.       will allocate more memory then
  1503.  
  1504.       y:=y+(y div 6);
  1505.       x:=x+(x div 6);
  1506.  
  1507.       We played it on the save side. Use this "guess work" very carefully}
  1508.  
  1509.  
  1510.       P := GlobalAllocPtr(HeapAllocFlags, Usize);
  1511.       if P = Nil then begin
  1512.         MessageDlg('Error allocation blob memory', mtInformation, [mbOk], 0);
  1513.         exit;
  1514.       end;
  1515.  
  1516.       if FUpdateAsJpeg then begin
  1517.          if not putjpgblob(P, USize, FSaveQuality, FSaveSmooth, Picture.Bitmap, TDBMultiMediaCallBack) then
  1518.            MessageDlg('Jpeg BLOB Write Error', mtInformation, [mbOk], 0);
  1519.       end else begin
  1520.          if not putbmpblob(P, USize, Picture.Bitmap, TDBMultiMediaCallBack) then
  1521.            MessageDlg('BMP BLOB Write Error', mtInformation, [mbOk], 0);
  1522.       end;
  1523.  
  1524.       Stream:=TMemoryStream.Create;
  1525.       Stream.Write(P^,USize);
  1526.       GlobalFreePtr(P);
  1527.  
  1528.       try
  1529.         TBlobField(FDataLink.Field).LoadFromStream(Stream);
  1530.       finally
  1531.         Stream.Free;
  1532.       end;
  1533.  
  1534.     end else
  1535.       TBlobField(FDataLink.Field).Clear;
  1536.    end;
  1537.    GetInfoAndType;
  1538. end;
  1539. {------------------------------------------------------------------------}
  1540.  
  1541. procedure TDBMultiMedia.CopyToClipboard;
  1542. begin
  1543.   if Picture.Graphic <> nil then Clipboard.Assign(Picture);
  1544. end;
  1545. {------------------------------------------------------------------------}
  1546.  
  1547. procedure TDBMultiMedia.CutToClipboard;
  1548. begin
  1549.   if Picture.Graphic <> nil then
  1550.   begin
  1551.     CopyToClipboard;
  1552.     if FDataLink.Edit then
  1553.       Picture.Graphic := nil;
  1554.   end;
  1555. end;
  1556. {------------------------------------------------------------------------}
  1557.  
  1558. procedure TDBMultiMedia.PasteFromClipboard;
  1559. begin
  1560.   if Clipboard.HasFormat(CF_PICTURE) and FDataLink.Edit then
  1561.     Picture.Assign(Clipboard);
  1562. end;
  1563. {------------------------------------------------------------------------}
  1564.  
  1565. procedure TDBMultiMedia.CreateParams(var Params: TCreateParams);
  1566. begin
  1567.   inherited CreateParams(Params);
  1568.   if FBorderStyle = bsSingle then
  1569.     Params.Style := Params.Style or WS_BORDER;
  1570. end;
  1571. {------------------------------------------------------------------------}
  1572.  
  1573. procedure TDBMultiMedia.KeyDown(var Key: Word; Shift: TShiftState);
  1574. begin
  1575.   inherited KeyDown(Key, Shift);
  1576.   case Key of
  1577.     VK_INSERT:
  1578.       if ssShift in Shift then PasteFromClipBoard else
  1579.         if ssCtrl in Shift then CopyToClipBoard;
  1580.     VK_DELETE:
  1581.       if ssShift in Shift then CutToClipBoard;
  1582.   end;
  1583. end;
  1584. {------------------------------------------------------------------------}
  1585.  
  1586. procedure TDBMultiMedia.KeyPress(var Key: Char);
  1587. begin
  1588.   inherited KeyPress(Key);
  1589.   case Key of
  1590.     ^X: CutToClipBoard;
  1591.     ^C: CopyToClipBoard;
  1592.     ^V: PasteFromClipBoard;
  1593.     #13: LoadMedia;
  1594.     #27: FDataLink.Reset;
  1595.   end;
  1596. end;
  1597. {------------------------------------------------------------------------}
  1598.  
  1599. procedure TDBMultiMedia.CMEnter(var Message: TCMEnter);
  1600. begin
  1601.   Invalidate; { Draw the focus marker }
  1602.   inherited;
  1603. end;
  1604. {------------------------------------------------------------------------}
  1605.  
  1606. procedure TDBMultiMedia.CMExit(var Message: TCMExit);
  1607. begin
  1608.   Invalidate; { Erase the focus marker }
  1609.   inherited;
  1610. end;
  1611. {------------------------------------------------------------------------}
  1612.  
  1613. procedure TDBMultiMedia.CMTextChanged(var Message: TMessage);
  1614. begin
  1615.   inherited;
  1616.   if not FPictureLoaded then Invalidate;
  1617. end;
  1618. {------------------------------------------------------------------------}
  1619.  
  1620. procedure TDBMultiMedia.WMLButtonDown(var Message: TWMLButtonDown);
  1621. begin
  1622.   if TabStop and CanFocus then SetFocus;
  1623.   inherited;
  1624. end;
  1625. {------------------------------------------------------------------------}
  1626.  
  1627. procedure TDBMultiMedia.WMLButtonDblClk(var Message: TWMLButtonDblClk);
  1628. begin
  1629.   LoadMedia;
  1630.   inherited;
  1631. end;
  1632. {------------------------------------------------------------------------}
  1633.  
  1634. procedure TDBMultiMedia.WMCut(var Message: TMessage);
  1635. begin
  1636.   CutToClipboard;
  1637. end;
  1638. {------------------------------------------------------------------------}
  1639.  
  1640. procedure TDBMultiMedia.WMCopy(var Message: TMessage);
  1641. begin
  1642.   CopyToClipboard;
  1643. end;
  1644. {------------------------------------------------------------------------}
  1645.  
  1646. procedure TDBMultiMedia.WMPaste(var Message: TMessage);
  1647. begin
  1648.   PasteFromClipboard;
  1649. end;
  1650. {------------------------------------------------------------------------}
  1651.  
  1652. procedure TDBMultiMedia.LoadFromFile(filename : TFilename);
  1653. var
  1654.    Cursor       :  hCursor;
  1655. begin
  1656.  
  1657.   if not FileExists(filename) then begin
  1658.     MessageDlg('File not found', mtInformation, [mbOk], 0);
  1659.     exit;
  1660.   end;
  1661.  
  1662.   if UpperCase(ExtractFileExt(filename)) <> '.JPG' then
  1663.   if UpperCase(ExtractFileExt(filename)) <> '.GIF' then
  1664.   if UpperCase(ExtractFileExt(filename)) <> '.PCX' then
  1665.   if UpperCase(ExtractFileExt(filename)) <> '.BMP' then
  1666.   if UpperCase(ExtractFileExt(filename)) <> '.WAV' then
  1667.   if UpperCase(ExtractFileExt(filename)) <> '.AVI' then
  1668.   if UpperCase(ExtractFileExt(filename)) <> '.MOV' then
  1669.   if UpperCase(ExtractFileExt(filename)) <> '.MID' then
  1670.   if UpperCase(ExtractFileExt(filename)) <> '.RMI' then
  1671.   {if UpperCase(ExtractFileExt(filename)) <> '.MPG' then}
  1672.   begin
  1673.     MessageDlg('A None Supported File Format', mtInformation, [mbOk], 0);
  1674.     exit;
  1675.   end;
  1676.  
  1677.   Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1678.  
  1679.   if FDataLink.Field is TBlobField then
  1680.     TBlobField(FDataLink.Field).LoadFromFile(filename)
  1681.   else begin
  1682.     SetCursor(Cursor);
  1683.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  1684.     exit;
  1685.   end;
  1686.   {GetInfoAndType;}
  1687.   SetCursor(Cursor);
  1688. end;
  1689. {------------------------------------------------------------------------}
  1690.  
  1691. procedure TDBMultiMedia.SaveToFile(filename : TFilename);
  1692. var
  1693.   Cursor       :  hCursor;
  1694. begin
  1695.   if FDataLink.Field is TBlobField then begin
  1696.  
  1697.     if TBlobField(FDataLink.Field).IsNull then begin
  1698.        MessageDlg('Can''t save, blobfield is empty', mtInformation, [mbOk], 0);
  1699.        exit;
  1700.     end;
  1701.  
  1702.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1703.     TBlobField(FDataLink.Field).SaveToFile(filename);
  1704.     GetInfoAndType;
  1705.     SetCursor(Cursor)
  1706.  
  1707.   end else begin
  1708.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  1709.     exit;
  1710.   end;
  1711. end;
  1712. {------------------------------------------------------------------------}
  1713.  
  1714. procedure TDBMultiMedia.SaveToFileAsBMP(filename : TFilename);
  1715. var
  1716.   Cursor       :  hCursor;
  1717. begin
  1718.   if FDataLink.Field is TBlobField then begin
  1719.  
  1720.     if TBlobField(FDataLink.Field).IsNull then begin
  1721.        MessageDlg('Can''t save, blobfield bitmap is empty', mtInformation, [mbOk], 0);
  1722.        exit;
  1723.     end;
  1724.  
  1725.     if picture.bitmap.empty then begin
  1726.        MessageDlg('Can''t save, image is not displayed, Set Autodisplay or double click display to view image first.',
  1727.                   mtInformation, [mbOk], 0);
  1728.        exit;
  1729.     end;
  1730.  
  1731.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1732.  
  1733.     if not putbmpfile(FileName, picture.Bitmap, TDBMultiMediaCallBack) then begin
  1734.       SetCursor(Cursor);
  1735.       MessageDlg('Writing bmp file failed', mtInformation, [mbOk], 0);
  1736.       exit;
  1737.     end;
  1738.  
  1739.     GetInfoAndType
  1740.  
  1741.   end else begin
  1742.     SetCursor(Cursor);
  1743.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  1744.     exit;
  1745.   end;
  1746.  
  1747.   SetCursor(Cursor);
  1748. end;
  1749. {------------------------------------------------------------------------}
  1750.  
  1751. procedure TDBMultiMedia.SaveToFileAsJpeg(filename : TFilename);
  1752. var
  1753.   Cursor       :  hCursor;
  1754. begin
  1755.   if FDataLink.Field is TBlobField then begin
  1756.  
  1757.     if TBlobField(FDataLink.Field).IsNull then begin
  1758.        MessageDlg('Can''t save, blobfield bitmap is empty', mtInformation, [mbOk], 0);
  1759.        exit;
  1760.     end;
  1761.  
  1762.     if picture.bitmap = nil then begin
  1763.        MessageDlg('Can''t save, image is not displayed', mtInformation, [mbOk], 0);
  1764.        exit;
  1765.     end;
  1766.  
  1767.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1768.  
  1769.     if not putjpgfile(FileName, FSaveQuality, FSaveSmooth, picture.Bitmap, TDBMultiMediaCallBack) then begin
  1770.       SetCursor(Cursor);
  1771.       MessageDlg('Writing jpg file failed', mtInformation, [mbOk], 0);
  1772.       exit;
  1773.     end;
  1774.  
  1775.     GetInfoAndType
  1776.  
  1777.   end else begin
  1778.     SetCursor(Cursor);
  1779.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  1780.     exit;
  1781.   end;
  1782.  
  1783.   SetCursor(Cursor);
  1784. end;
  1785.  
  1786.  
  1787. {------------------------------------------------------------------------}
  1788.  
  1789. function TDBMultiMedia.GetInfoAndType : String;
  1790. var
  1791.  Stream       :  TMemoryStream;
  1792.  Hdr          :  Array[0..45] of char;
  1793.  i            :  Byte;
  1794. begin
  1795.   if (FDataLink.Field is TBlobField) then
  1796.    if TBlobField(FDataLink.Field).IsNull then exit;
  1797.  
  1798.    BFileType := 'Empty';
  1799.    Bwidth:=-1;
  1800.    BHeight:=-1;
  1801.    Bbitspixel:=-1;
  1802.    Bplanes:=-1;
  1803.    Bnumcolors:=-1;
  1804.    Bcompression:='-1';
  1805.    BSize:=-1;
  1806.    GetInfoAndType :='-1';
  1807.  
  1808.    Stream:=TMemoryStream.Create;
  1809.    TBlobField(FDataLink.Field).SaveToStream(Stream);
  1810.  
  1811.    if Stream.Memory = nil then begin
  1812.      MessageDlg('Error allocation temporary blob memory', mtInformation, [mbOk], 0);
  1813.      exit;
  1814.    end;
  1815.  
  1816.  
  1817.    Stream.Seek(0,0);
  1818.    Stream.read(hdr,SizeOf(Hdr)-1);
  1819.  
  1820.    for i:=0 to SizeOf(hdr)-1 do
  1821.     if hdr[i] = #0 then hdr[i]:=' ';
  1822.  
  1823.    if StrPos(hdr,'RIFF') <> nil then begin
  1824.         Bwidth:=-1;
  1825.         BHeight:=-1;
  1826.         Bbitspixel:=-1;
  1827.         Bplanes:=-1;
  1828.         Bnumcolors:=-1;
  1829.         Bcompression:='RIFF';
  1830.  
  1831.      if StrPos(hdr,'WAV') <> nil then begin
  1832.         BSize:=Stream.Size;
  1833.         BFileType:= 'WAV';
  1834.         GetInfoAndType:='WAV';
  1835.      end;
  1836.  
  1837.      if StrPos(hdr,'AVI') <> nil then begin
  1838.         BSize:=Stream.Size;
  1839.         BFileType:= 'AVI';
  1840.         GetInfoAndType:='AVI';
  1841.      end;
  1842.  
  1843.      if StrPos(hdr,'RMID') <> nil then begin
  1844.         BSize:=Stream.Size;
  1845.         BFileType:= 'RMI';
  1846.         GetInfoAndType:='RMI';
  1847.      end;
  1848.  
  1849.      if Stream.Memory <> nil then Stream.Free;
  1850.      exit;
  1851.    end else
  1852.  
  1853. {   if StrPos(hdr,'mpeg') <> nil then begin
  1854.         Bwidth:=-1;
  1855.         BHeight:=-1;
  1856.         Bbitspixel:=-1;
  1857.         Bplanes:=-1;
  1858.         Bnumcolors:=-1;
  1859.         Bcompression:='MPEG';
  1860.         BSize:=Stream.Size;
  1861.         BFileType:= 'MPG';
  1862.         GetInfoAndType:='MPG';
  1863.         if Stream.Memory <> nil then Stream.Free;
  1864.         exit;
  1865.    end else}
  1866.  
  1867.    if StrPos(hdr,'mdat') <> nil then begin
  1868.         Bwidth:=-1;
  1869.         BHeight:=-1;
  1870.         Bbitspixel:=-1;
  1871.         Bplanes:=-1;
  1872.         Bnumcolors:=-1;
  1873.         Bcompression:='QTM';
  1874.         BSize:=Stream.Size;
  1875.         BFileType:= 'MOV';
  1876.         GetInfoAndType:='MOV';
  1877.         if Stream.Memory <> nil then Stream.Free;
  1878.         exit;
  1879.    end else
  1880.  
  1881.    if StrPos(hdr,'MThd') <> nil then begin
  1882.         Bwidth:=-1;
  1883.         BHeight:=-1;
  1884.         Bbitspixel:=-1;
  1885.         Bplanes:=-1;
  1886.         Bnumcolors:=-1;
  1887.         Bcompression:='MIDI';
  1888.         BSize:=Stream.Size;
  1889.         BFileType:= 'MID';
  1890.         GetInfoAndType:='MID';
  1891.         if Stream.Memory <> nil then Stream.Free;
  1892.         exit;
  1893.      end else
  1894.  
  1895.  if not GetBlobInfo(Stream.Memory,
  1896.                     Stream.Size,
  1897.                     BFileType,
  1898.                     Bwidth,
  1899.                     BHeight,
  1900.                     Bbitspixel,
  1901.                     Bplanes,
  1902.                     Bnumcolors,
  1903.                     Bcompression) then
  1904.     MessageDlg('blobfield getinfo failed', mtInformation, [mbOk], 0) else
  1905.     begin
  1906.          BSize:=Stream.Size;
  1907.          if UpperCase(BFileType) = 'GIF' then GetInfoAndType:='GIF' else
  1908.          if UpperCase(BFileType) = 'PCX' then GetInfoAndType:='PCX' else
  1909.          if UpperCase(BFileType) = 'JPEG' then GetInfoAndType:='JPG' else
  1910.          if UpperCase(BFileType) = 'BMP' then GetInfoAndType:='BMP';
  1911.     end;
  1912.   if Stream.Memory <> nil then Stream.Free;
  1913. end;
  1914. {------------------------------------------------------------------------}
  1915.  
  1916. function TDBMultiMedia.GetSmooth : Byte;
  1917. begin
  1918.   GetSmooth:=FSaveSmooth;
  1919. end;
  1920. {------------------------------------------------------------------------}
  1921.  
  1922. procedure TDBMultiMedia.SetSmooth(Smooth : Byte);
  1923. begin
  1924.   if (Smooth > 100) or (Smooth < 0) then FSaveSmooth:=5 else
  1925.    FSaveSmooth:=Smooth;
  1926. end;
  1927. {------------------------------------------------------------------------}
  1928.  
  1929. function TDBMultiMedia.GetQuality : Byte;
  1930. begin
  1931.   GetQuality:=FSaveQuality;
  1932. end;
  1933. {------------------------------------------------------------------------}
  1934.  
  1935. procedure TDBMultiMedia.SetQuality(Quality : Byte);
  1936. begin
  1937.   if (Quality > 100) or (Quality < 1) then FSaveQuality:=25 else
  1938.    FSaveQuality:=Quality;
  1939. end;
  1940. {------------------------------------------------------------------------}
  1941. function TDBMultiMedia.GetDither : Byte;
  1942. begin
  1943.   GetDither:=Fdither
  1944. end;
  1945. {------------------------------------------------------------------------}
  1946.  
  1947. procedure TDBMultiMedia.SetDither(dith : Byte);
  1948. begin
  1949.   Fdither:=4;
  1950.   case dith of
  1951.             0..4 :Fdither:=dith;
  1952.   end;
  1953. end;
  1954. {------------------------------------------------------------------------}
  1955.  
  1956. function TDBMultiMedia.GetRes : Byte;
  1957. begin
  1958.   GetRes:=FResolution;
  1959. end;
  1960. {------------------------------------------------------------------------}
  1961.  
  1962. function TDBMultiMedia.GetTempPath : String;
  1963. begin
  1964.   GetTempPath:=FTempFilePath;
  1965. end;
  1966. {------------------------------------------------------------------------}
  1967.  
  1968.  
  1969. procedure TDBMultiMedia.SetTempPath(temppath : string);
  1970. var
  1971.  temp, OldDir : string;
  1972. begin
  1973.   temp:=AddBackSlash(TempPath);
  1974.   GetDir(0,OldDir);
  1975.   try
  1976.      ChDir(temp);
  1977.   except
  1978.      temp:='C:\';
  1979.   end;
  1980.   ChDir(OldDir);
  1981.   FTempFilePath:=temp;
  1982. end;
  1983.  
  1984. {------------------------------------------------------------------------}
  1985.  
  1986.  
  1987. procedure TDBMultiMedia.SetRes(res : Byte);
  1988. begin
  1989.   FResolution:=8;
  1990.   case res of
  1991.             4 :FResolution:=res;
  1992.             8 :FResolution:=res;
  1993.             24:FResolution:=res;
  1994.   end;
  1995. end;
  1996. {------------------------------------------------------------------------}
  1997.  
  1998. function TDBMultiMedia.GetMediaPlayer: TDBMediaPlayer;
  1999. begin
  2000.  Result:=FMediaPlayer;
  2001. end;
  2002. {------------------------------------------------------------------------}
  2003.  
  2004. procedure TDBMultiMedia.SetMediaPlayer(Value: TDBMediaPlayer);
  2005. begin
  2006.   FMediaPlayer:=Value;
  2007. end;
  2008. {------------------------------------------------------------------------}
  2009.  
  2010. function TDBMultiMedia.AddBackSlash(DirName : string) : string;
  2011. const
  2012.   DosDelimSet : set of Char = ['\', ':', #0];
  2013.   begin
  2014.     if DirName[Length(DirName)] in DosDelimSet then
  2015.       AddBackSlash := DirName
  2016.     else
  2017.       AddBackSlash := DirName+'\';
  2018.   end;
  2019. {------------------------------------------------------------------------}
  2020.  
  2021. function TDBMultiMedia.IsValidMultiMedia(Name : PChar) : boolean;
  2022.  var
  2023.   temp : Array[0..25] of char;
  2024. begin
  2025.    Result:=ValidMultiMedia(Name);
  2026. {  GetProfileString('mci extensions',Name,'none',temp,SizeOf(temp));
  2027.   if StrPas(temp) = 'none' then
  2028.     result:=false
  2029.   else
  2030.     result:=true;}
  2031. end;
  2032. {------------------------------------------------------------------------}
  2033.  
  2034. function TDBMultiMedia.GetMultiMediaExtensions : String;
  2035. var
  2036.   temp : string;
  2037. begin
  2038.   temp:='All MultiMedia|*.bmp;*.gif;*.pcx;*.jpg;';
  2039.  
  2040.   if IsValidMultiMedia('wav') then
  2041.     temp:=temp+'*.wav;';
  2042.   if IsValidMultiMedia('mid') then
  2043.     temp:=temp+'*.mid;';
  2044.   if IsValidMultiMedia('rmi') then
  2045.     temp:=temp+'*.rmi;';
  2046.   if IsValidMultiMedia('avi') then
  2047.     temp:=temp+'*.avi;';
  2048.   if IsValidMultiMedia('mov') then
  2049.     temp:=temp+'*.mov;';
  2050.  {if IsValidMultiMedia('mgp') then
  2051.     temp:=temp+'*.mpg;';}
  2052.  
  2053.   temp:=temp+'|BMP Files|*.bmp';
  2054.   temp:=temp+'|GIF Files|*.gif';
  2055.   temp:=temp+'|JPG Files|*.jpg';
  2056.   temp:=temp+'|PCX Files|*.pcx';
  2057.  
  2058.   if IsValidMultiMedia('wav') then
  2059.     temp:=temp+'|Wave Files|*.wav';
  2060.   if IsValidMultiMedia('mid') then
  2061.     temp:=temp+'|Midi Files|*.mid';
  2062.   if IsValidMultiMedia('rmi') then
  2063.     temp:=temp+'|RMI Files|*.rmi';
  2064.   if IsValidMultiMedia('avi') then
  2065.     temp:=temp+'|AVI Files|*.avi';
  2066.   if IsValidMultiMedia('mov') then
  2067.     temp:=temp+'|Movie Files|*.mov';
  2068.   {if IsValidMultiMedia('mgp') then
  2069.    temp:=temp+'|Mpeg Files|*.mpg';}
  2070.  
  2071.   Result:=temp;
  2072. end;
  2073. {------------------------------------------------------------------------}
  2074.  
  2075. procedure TDBMultiMedia.TimerNotify(var Message: TMessage);
  2076. var
  2077.   MPosition : integer;
  2078. begin
  2079.   if FMediaPlayer = nil then exit;
  2080.  
  2081.   MPosition:=Round(FMediaPlayer.Position * (100 / FMediaPlayer.length));
  2082.  
  2083.   if @TDBMultiMediaCallBack <> nil then
  2084.    TDBMultiMediaCallBack(MPosition);
  2085.  
  2086.   if (FAutoRePlayMM) and (MPosition >= 100) and (FMediaPlayer.FileName <> '') then
  2087.    FMediaPlayer.Play;
  2088.  
  2089. end;
  2090. {------------------------------------------------------------------------}
  2091.  
  2092.  
  2093.  
  2094. begin
  2095.  TDBMultiImageCallBack:=nil;
  2096.  TDBMultiMediaCallBack:=nil;
  2097. end.
  2098.  
  2099.